home *** CD-ROM | disk | FTP | other *** search
/ FishMarket 1.0 / FishMarket v1.0.iso / fishies / 551-575 / disk_556 / scheme2c / scheme-src.lzh / scrt / scrt3.sc < prev    next >
Text File  |  1991-10-11  |  10KB  |  296 lines
  1. ;;; SCHEME->C Runtime Library
  2.  
  3. ;*              Copyright 1989 Digital Equipment Corporation
  4. ;*                         All Rights Reserved
  5. ;*
  6. ;* Permission to use, copy, and modify this software and its documentation is
  7. ;* hereby granted only under the following terms and conditions.  Both the
  8. ;* above copyright notice and this permission notice must appear in all copies
  9. ;* of the software, derivative works or modified versions, and any portions
  10. ;* thereof, and both notices must appear in supporting documentation.
  11. ;*
  12. ;* Users of this software agree to the terms and conditions set forth herein,
  13. ;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
  14. ;* right and license under any changes, enhancements or extensions made to the
  15. ;* core functions of the software, including but not limited to those affording
  16. ;* compatibility with other hardware or software environments, but excluding
  17. ;* applications which incorporate this software.  Users further agree to use
  18. ;* their best efforts to return to Digital any such changes, enhancements or
  19. ;* extensions that they make and inform Digital of noteworthy uses of this
  20. ;* software.  Correspondence should be provided to Digital at:
  21. ;* 
  22. ;*                       Director of Licensing
  23. ;*                       Western Research Laboratory
  24. ;*                       Digital Equipment Corporation
  25. ;*                       100 Hamilton Avenue
  26. ;*                       Palo Alto, California  94301  
  27. ;* 
  28. ;* This software may be distributed (but not offered for sale or transferred
  29. ;* for compensation) to third parties, provided such third parties agree to
  30. ;* abide by the terms and conditions of this notice.  
  31. ;* 
  32. ;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
  33. ;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
  34. ;* MERCHANTABILITY AND FITNESS.   IN NO EVENT SHALL DIGITAL EQUIPMENT
  35. ;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
  36. ;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
  37. ;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
  38. ;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
  39. ;* SOFTWARE.
  40.  
  41. (module scrt3
  42.     (top-level
  43.     CHAR? CHAR=? CHAR<? CHAR>? CHAR<=? CHAR>=?
  44.     CHAR-CI=? CHAR-CI<? CHAR-CI>? CHAR-CI<=? CHAR-CI>=?
  45.     CHAR-ALPHABETIC? CHAR-NUMERIC? CHAR-WHITESPACE? CHAR-UPPER-CASE?
  46.         CHAR-LOWER-CASE? CHAR-UPCASE CHAR-DOWNCASE CHAR->INTEGER INTEGER->CHAR
  47.     STRING? STRING-LENGTH STRING-REF STRING-SET!
  48.     STRING=? STRING<? STRING>? STRING<=? STRING>=?
  49.     STRING-CI=? STRING-CI<? STRING-CI>? STRING-CI<=? STRING-CI>=?
  50.     SUBSTRING STRING-APPEND STRING->LIST LIST->STRING STRING-FILL!))
  51.  
  52. ;;; 6.6  Characters
  53.  
  54. (define (CHAR? x) (char? x))
  55.  
  56. (define (CHAR=? x y) (char=? x y))
  57.  
  58. (define (CHAR<? x y) (char<? x y))
  59.  
  60. (define (CHAR>? x y) (char>? x y))
  61.  
  62. (define (CHAR<=? x y) (not (char>? x y)))
  63.  
  64. (define (CHAR>=? x y) (not (char<? x y)))
  65.  
  66. (define CHAR-UPCASE-TABLE
  67.     (let ((v (make-vector 256)))
  68.      (do ((i 0 (+ i 1)))
  69.          ((= i 256)
  70.           (do ((i (char->integer #\a) (+ i 1))
  71.            (j (char->integer #\A) (+ j 1))
  72.            (c 0 (+ c 1)))
  73.           ((= c 26) v)
  74.           (vector-set! v i (integer->char j))))
  75.          (vector-set! v i (integer->char i)))))
  76.  
  77. (define-in-line (UPCASE char)
  78.     (vector-ref char-upcase-table (char->integer char)))
  79.  
  80. (define (CHAR-CI=? x y) (char=? (upcase x) (upcase y)))
  81.  
  82. (define (CHAR-CI<? x y) (char<? (upcase x) (upcase y)))
  83.  
  84. (define (CHAR-CI>? x y) (char>? (upcase x) (upcase y)))
  85.  
  86. (define (CHAR-CI<=? x y) (char<=? (upcase x) (upcase y)))
  87.  
  88. (define (CHAR-CI>=? x y) (char>=? (upcase x) (upcase y)))
  89.  
  90. (define (CHAR-ALPHABETIC? x)
  91.     (if (not (char? x))
  92.     (error 'CHAR-ALPHABETIC? "Argument not a CHAR"))
  93.     (or (and (char>=? x #\A) (char<=? x #\Z))
  94.     (and (char>=? x #\a) (char<=? x #\z))))
  95.  
  96. (define (CHAR-NUMERIC? x)
  97.     (if (not (char? x))
  98.         (error 'CHAR-NUMERIC? "Argument not a CHAR"))
  99.     (and (char>=? x #\0) (char<=? x #\9)))
  100.  
  101. (define (CHAR-WHITESPACE? x)
  102.     (if (not (char? x))
  103.     (error 'CHAR-WHITESPACE? "Argument not a CHAR"))
  104.     (set! x (char->integer x))
  105.     (or (and (>= x #o11) (<= x #o15)) (= x #o40)))
  106.  
  107. (define (CHAR-UPPER-CASE? letter)
  108.     (if (not (char? letter))
  109.     (error 'CHAR-UPPER-CASE? "Argument not a CHAR"))
  110.     (and (char>=? letter #\A) (char<=? letter #\Z)))
  111.  
  112. (define (CHAR-LOWER-CASE? letter)
  113.     (if (not (char? letter))
  114.     (error 'CHAR-LOWER-CASE? "Argument not a CHAR"))
  115.     (and (char>=? letter #\a) (char<=? letter #\z)))
  116.  
  117. (define (CHAR-UPCASE x)
  118.     (if (not (char? x))
  119.     (error 'CHAR-UPCASE "Argument not a CHAR"))
  120.     (upcase x))
  121.  
  122. (define (CHAR-DOWNCASE x)
  123.     (if (not (char? x))
  124.     (error 'CHAR-DOWNCASE "Argument not a CHAR"))
  125.     (if (and (char-alphabetic? x) (char-upper-case? x))
  126.     (integer->char (+ (char->integer x) 32))
  127.     x))
  128.  
  129. (define (CHAR->INTEGER x) (char->integer x))
  130.  
  131. (define (INTEGER->CHAR x) (integer->char x))
  132.  
  133. ;;; 6.7  Strings.
  134.  
  135. (define (STRING? x) (string? x))
  136.  
  137. (define (STRING-LENGTH x) (string-length x))
  138.  
  139. (define (STRING-REF x y) (string-ref x y))
  140.  
  141. (define (STRING-SET! x y z) (string-set! x y z))
  142.  
  143. ;;; In-line definitions for use in the following routines:
  144.  
  145. (define-in-line (STRING-LENGTH s) ((lap (s) (C_FIXED (STRING_LENGTH s))) s))
  146.  
  147. (define-in-line (STRING-REF s x) ((lap (s x) (C_CHAR (STRING_CHAR s x))) s x))
  148.  
  149. (define-in-line (UCSTRING-REF s x)
  150.     (upcase ((lap (s x) (C_CHAR (STRING_CHAR s x))) s x)))
  151.  
  152. (define-in-line (STRING-SET! s x c)
  153.     ((lap (s x c) (SET (STRING_CHAR s x) (CHAR_C c)) c) s x c))
  154.  
  155. (define (STRING=? x y)
  156.     (if (or (not (string? x)) (not (string? y)))
  157.     (error 'STRING=? "Argument(s) not a STRING"))
  158.     (let ((xl (string-length x))
  159.       (yl (string-length y)))
  160.      (if (= xl yl)
  161.          (do ((i 0 (+ i 1)))
  162.          ((or (= i xl)
  163.               (not (eq? (string-ref x i) (string-ref y i))))
  164.           (= i xl)))
  165.          #f)))
  166.  
  167. (define (STRING<? x y)
  168.     (if (or (not (string? x)) (not (string? y)))
  169.     (error 'STRING<? "Argument(s) not a STRING"))
  170.     (let* ((xl      (string-length x))
  171.        (yl      (string-length y))
  172.        (minxlyl (min xl yl)))
  173.       (let test ((i 0))
  174.            (if (= i minxlyl)
  175.            (< xl yl)
  176.            (let ((cx (string-ref x i))
  177.              (cy (string-ref y i)))
  178.             (if (eq? cx cy) (test (+ i 1)) (char<? cx cy)))))))
  179.  
  180. (define (STRING>? x y)
  181.     (if (or (not (string? x)) (not (string? y)))
  182.         (error 'STRING>? "Argument(s) not a STRING"))
  183.     (let* ((xl      (string-length x))
  184.            (yl      (string-length y))
  185.            (minxlyl (min xl yl)))
  186.       (let test ((i 0))
  187.            (if (= i minxlyl)
  188.            (> xl yl)
  189.            (let ((cx (string-ref x i))
  190.              (cy (string-ref y i)))
  191.             (if (eq? cx cy) (test (+ i 1)) (char>? cx cy)))))))
  192.  
  193. (define (STRING<=? x y) (not (string>? x y)))
  194.  
  195. (define (STRING>=? x y) (not (string<? x y)))
  196.  
  197. (define (STRING-CI=? x y)
  198.     (if (or (not (string? x)) (not (string? y)))
  199.     (error 'STRING-CI=? "Argument(s) not a STRING"))
  200.     (let ((xl (string-length x))
  201.       (yl (string-length y)))
  202.      (if (= xl yl)
  203.          (do ((i 0 (+ i 1)))
  204.          ((or (= i xl)
  205.               (not (eq? (ucstring-ref x i) (ucstring-ref y i))))
  206.           (= i xl)))
  207.          #f)))
  208.  
  209. (define (STRING-CI<? x y)
  210.     (if (or (not (string? x)) (not (string? y)))
  211.     (error 'STRING-CI<? "Argument(s) not a STRING"))
  212.     (let* ((xl      (string-length x))
  213.        (yl      (string-length y))
  214.        (minxlyl (min xl yl)))
  215.       (let test ((i 0))
  216.            (if (= i minxlyl)
  217.            (< xl yl)
  218.            (let ((cx (ucstring-ref x i))
  219.              (cy (ucstring-ref y i)))
  220.             (if (eq? cx cy) (test (+ i 1)) (char<? cx cy)))))))
  221.  
  222. (define (STRING-CI>? x y)
  223.     (if (or (not (string? x)) (not (string? y)))
  224.         (error 'STRING-CI>? "Argument(s) not a STRING"))
  225.     (let* ((xl      (string-length x))
  226.            (yl      (string-length y))
  227.            (minxlyl (min xl yl)))
  228.       (let test ((i 0))
  229.            (if (= i minxlyl)
  230.            (> xl yl)
  231.            (let ((cx (ucstring-ref x i))
  232.              (cy (ucstring-ref y i)))
  233.             (if (eq? cx cy) (test (+ i 1)) (char>? cx cy)))))))
  234.  
  235. (define (STRING-CI<=? x y) (not (string-ci>? x y)))
  236.  
  237. (define (STRING-CI>=? x y) (not (string-ci<? x y)))
  238.  
  239. (define (SUBSTRING x y z)
  240.     (if (not (string? x))
  241.     (error 'SUBSTRING "Argument is not a STRING"))
  242.     (if (or (not (integer? y)) (negative? y) (not (integer? z))
  243.         (< z y) (> z (string-length x)))
  244.     (error 'SUBSTRING "Argument(s) not a STRING INDEX"))
  245.     (do ((i y (+ i 1))
  246.      (j 0 (+ j 1))
  247.      (s (make-string (- z y))))
  248.     ((= i z) s)
  249.     (string-set! s j (string-ref x i))))
  250.  
  251. (define (STRING-APPEND . x)
  252.     (do ((new (let loop ((sl x) (len 0))
  253.            (cond ((null? sl) (make-string len))
  254.              ((string? (car sl))
  255.               (loop (cdr sl) (+ len (string-length (car sl)))))
  256.              (else
  257.                   (error 'STRING-APPEND
  258.                      "Argument is not a STRING: ~s"
  259.                      (car sl))))))
  260.      (i 0 (+ i (string-length (car sl))))
  261.      (sl x (cdr sl)))
  262.     ((null? sl) new)
  263.     (do ((old (car sl))
  264.          (j (- (string-length (car sl)) 1) (- j 1)))
  265.         ((eq? j -1))
  266.         (string-set! new (+ i j) (string-ref old j)))))
  267.  
  268. (define (STRING->LIST x)
  269.     (if (not (string? x))
  270.     (error 'STRING->LIST "Argument is not a STRING: ~s" x))
  271.     (do ((i (- (string-length x) 1) (- i 1))
  272.      (l '()))
  273.     ((= i -1) l)
  274.     (set! l (cons (string-ref x i) l))))
  275.  
  276. (define (LIST->STRING x)
  277.     (do ((i 0 (+ i 1))
  278.      (l x (cdr l))
  279.      (s (make-string (length x))))
  280.     ((null? l) s)
  281.     (let ((char (car l)))
  282.          (if (not (char? char))
  283.          (error 'LIST->STRING
  284.             "Argument is not a list of CHARACTERS: ~s"
  285.             x))
  286.          (string-set! s i char))))
  287.  
  288. (define (STRING-FILL! s c)
  289.     (if (not (string? s))
  290.     (error 'STRING-FILL! "Argument is not a STRING: ~s" s))
  291.     (if (not (char? c))
  292.     (error 'STRING-FILL! "Argument is not a CHAR: ~s" c))
  293.     (do ((i (- (string-length s) 1) (- i 1)))
  294.     ((= i -1) s)
  295.     (string-set! s i c)))
  296.